home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / static1.scm < prev    next >
Text File  |  1995-10-31  |  19KB  |  643 lines
  1. ;;; Package for Static heaps for the Scheme Shell
  2. ;;; Copyright (c) 1995 by Brian D. Carlstrom.
  3.  
  4. ;;; based on Scheme48 implementation.
  5. ;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;; prefix for temp files - in their own dir
  9. (define *temp-dir*   "/tmp")
  10.  
  11. (define (test) 
  12.   (scsh-do-it *scsh-image* *temp-dir* *image-lib* "gcc -c" "ar cq"))
  13.  
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. (define-record heap
  16.   (length    0)
  17.   (objects '())
  18.   )
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20. (define (scsh-do-it infile tempdir outfile cc-command ar-command)
  21.   (let* ((temp-dir (format #f "~a/scsh~s" tempdir (pid)))
  22.      (prefix (string-append temp-dir "/static"))
  23.      (start (read-heap-image infile)))
  24.     (receive (pure impure reloc externs)
  25.     (create-heaps-and-tables)
  26.       (if (file-exists? temp-dir)
  27.       (if (file-directory? temp-dir)
  28.           (with-cwd temp-dir
  29.             (map delete-file (directory-files temp-dir #t)))
  30.           (delete-file temp-dir)))
  31.       (create-directory temp-dir #o755 #t)
  32.       (with-cwd temp-dir
  33.         (write-c-header-file pure impure externs infile outfile prefix)
  34.         (write-c-image pure impure reloc externs prefix)
  35.         (write-main-c-file start reloc prefix)
  36.         (compile-c-files cc-command prefix))
  37.       (archive-files ar-command outfile prefix)
  38.       )))
  39.  
  40.  
  41. (define debug #f)
  42.  
  43. (define (vm-string->string x)
  44.   (cond ((vm-string? x)
  45.      (let ((len (vm-string-length x)))
  46.        (let loop ((i 0) 
  47.               (l '()))
  48.          (cond ((= i len) 
  49.             (list->string (reverse l)))
  50.            (else
  51.             (loop (+ i 1) (cons (vm-string-ref x i) l)))))))
  52.     (else
  53.      (message x " is not a vm-string"))))
  54.  
  55. (define (read-heap-image infile)
  56.   (let ((bytes (file-info:size (file-info infile))))
  57.     (init (inexact->exact (floor (* 1.1 bytes))) infile)))
  58. ; XXX need little extra space for find-all-xs
  59.  
  60. (define (create-heaps-and-tables)
  61.   (let* ((n       (nchunks))
  62.      (  pure  (make-vector n))
  63.      (impure  (make-vector n))
  64.      (reloc   (make-vector n))
  65.      (externs (make-table   )))
  66.     ;; initialize to blanks
  67.     (let loop ((i 0))
  68.       (cond ((not (= i n))
  69.          (vector-set!   pure i (make-heap ))
  70.          (vector-set! impure i (make-heap ))
  71.          (vector-set!  reloc i (make-table))
  72.          (loop (+ i 1)))))
  73.     (scsh-for-each-stored-object
  74.      (lambda (chunk)
  75.        (format #t "Reading chunk number ~s" chunk))
  76.      (lambda (chunk x len)
  77.        (if debug
  78.        (write x))
  79.        (let* ((mutable (mutable? x))
  80.           (heap (vector-ref (if mutable impure pure) chunk)))
  81.      (table-set! (vector-ref reloc chunk) x (heap:length heap))
  82.      (set-heap:objects heap (cons x (heap:objects heap)))
  83.      (set-heap:length  heap (+ len  (heap:length  heap)))
  84.      (cond (debug
  85.         (display (if mutable "   mutable " " immutable "))
  86.         (cond ((d-vector? x)  (display " d-vector"))
  87.               ((vm-string? x) (display "vm-string"))
  88.               (else           (display " b-vector")))
  89.         (let ((m (heap:length (vector-ref impure chunk)))
  90.               (i (heap:length (vector-ref   pure chunk))))
  91.           (message " m" m "+i" i "=" (+ m i))))))
  92.        (if (= (header-type (stob-header x)) (enum stob external))
  93.        (table-set! externs 
  94.                (external-value x) 
  95.                (vm-string->string (external-name x))))
  96.        )
  97.      (lambda (chunk) 
  98.        (newline)))
  99.     (let loop ((i 0))
  100.       (cond ((not (= i n))
  101.          (let ((p (vector-ref   pure i))
  102.            (i (vector-ref impure i)))
  103.            (set-heap:objects p (reverse (heap:objects p)))
  104.            (set-heap:objects i (reverse (heap:objects i))))
  105.          (loop (+ i 1)))))
  106.     (values pure impure reloc externs)))
  107.  
  108. (define (write-c-header-file pure impure externs infile outfile prefix)
  109.   (message "Writing header file")
  110.   (call-with-output-file (string-append prefix ".h")
  111.     (lambda (port)
  112.       (format port "/* Static Heap File Automatically Generated~%")
  113.       (format port " * by   scsh/static.scm~%")
  114.       (format port " * from ~a~%" infile)
  115.       (format port " * to   ~a~%" outfile)
  116.       (format port " */~%")
  117.       (let ((n (nchunks)))
  118.     (do ((i 0 (+ i 1)))
  119.         ((= i n))
  120.       (format port "extern const long p~s[~s];~%" i 
  121.           (quotient (heap:length (vector-ref   pure i)) 4)))
  122.     (do ((i 0 (+ i 1)))
  123.         ((= i n))
  124.       (format port "extern long i~s[~s];~%" i
  125.           (quotient (heap:length (vector-ref impure i)) 4))))
  126.       (table-walk
  127.        (lambda (address name)
  128.      (format port "const extern ~a();~%" name))
  129.        externs)
  130.       )))
  131.  
  132. (define (d-vector-for-each proc d-vector)
  133.   (do ((i 0 (+ i 1)))
  134.       ((>= i (d-vector-length d-vector)))
  135.     (proc (d-vector-ref d-vector i))))
  136.  
  137. (define (write-c-image pure impure reloc externs prefix)
  138.   (message "Writing   pure c files")
  139.   (scsh-write-c-image   pure "p" "const " reloc externs prefix)
  140.   (message "Writing impure c files")
  141.   (scsh-write-c-image impure "i" ""       reloc externs prefix))
  142.  
  143. (define (scsh-write-c-image heap name const reloc externs prefix)
  144.   (let ((n (nchunks)))
  145.     (let chunk-loop ((c 0))
  146.       (cond ((not (= c n))
  147.          (format #t "Writing ~a-~a~s.c~%" prefix name c)
  148.          (call-with-output-file 
  149.          (format #f "~a-~a~s.c" prefix name c)
  150.            (lambda (port)         
  151.          (format port "#include \"~a.h\"~%" prefix)
  152.          (format port "~a long ~a~s[]={~%" const name c)
  153.          (let ((heap (vector-ref heap c)))
  154.            (let heap-loop ((l (heap:objects heap)))
  155.              (cond ((not (null? l))
  156.                 (scsh-emit-initializer (car l) reloc externs port)
  157.                 (heap-loop (cdr l))))))
  158.          (display "};" port)
  159.          (newline port)))
  160.          (chunk-loop (+ 1 c)))))))
  161.  
  162. (define (write-main-c-file start reloc prefix)
  163.   (let ((n (nchunks)))
  164.     (call-with-output-file (string-append prefix ".c")
  165.       (lambda (port)
  166.     (format port "#include \"~a.h\"~%" prefix)
  167.     (format port "const long p_count = ~s;~%" n)
  168.     (format port "const long i_count = ~s;~%" n)
  169.         
  170.     (format port "const long * const p_areas[~s] = {" n)
  171.     (do ((i 0 (+ i 1)))
  172.         ((= i n))
  173.       (format port "(const long *) &p~s, " i))
  174.     (format port "};~%")
  175.  
  176.     (format port "long * const i_areas[~s] = {" n)
  177.     (do ((i 0 (+ i 1)))
  178.         ((= i n))
  179.       (format port "(long *) &i~s, " i))
  180.     (format port "};~%")
  181.  
  182.     (format port "const long p_sizes[~s] = {" n)
  183.     (do ((i 0 (+ i 1)))
  184.         ((= i n))
  185.       (format port "sizeof(p~s), " i))
  186.     (format port "};~%")
  187.  
  188.     (format port "const long i_sizes[~s] = {" n)
  189.     (do ((i 0 (+ i 1)))
  190.         ((= i n))
  191.       (format port "sizeof(i~s), " i))
  192.     (format port "};~%")
  193.  
  194.     (display "const long entry = " port)
  195.     (scsh-emit-descriptor start reloc port)
  196.     (write-char #\; port)
  197.     (newline port)))))
  198.  
  199. (define (compile-c-files cc-command prefix)
  200.   (let ((n (nchunks))
  201.     (cc (line->list cc-command)))
  202.     (message "Compiling main C file")
  203.     (run (,@(append cc (list (format #f "~a.c" prefix)))))
  204.     (do ((i 0 (+ i 1)))
  205.     ((= i n))
  206.       (message "Compiling C file for   pure chunk " i)
  207.       (run (,@(append cc 
  208.               (list (format #f "~a-p~s.c" prefix i)))))
  209.       (message "Compiling C file for impure chunk " i)
  210.       (run (,@(append cc 
  211.               (list (format #f "~a-i~s.c" prefix i))))))))
  212.  
  213. (define (archive-files ar-command outfile prefix)
  214.   (let ((n (nchunks))
  215.     (ar (line->list ar-command)))
  216.     (message "Archiving object files")
  217.     (run (,@(append 
  218.          ar
  219.          (cons 
  220.           outfile
  221.           (let loop ((i 0)
  222.              (l '()))
  223.         (cond ((not (= i n))
  224.                (loop (+ i 1)
  225.                  (cons 
  226.                   (format #f "~a-i~s.o" prefix i)
  227.                   (cons
  228.                    (format #f "~a-p~s.o" prefix i)
  229.                    l))))
  230.               (else 
  231.                (reverse         
  232.             (cons 
  233.              (string-append prefix ".o")
  234.              l)))))))))))
  235.  
  236. (define (scsh-emit-initializer x reloc externs port)
  237.   (write-hex port (stob-header x))
  238.   (cond ((d-vector? x)
  239.      (scsh-emit-d-vector-initializer x reloc port))
  240.     ((vm-string? x)
  241.      (scsh-emit-vm-string-initializer x port))
  242.     (else
  243.      (scsh-emit-b-vector-initializer x reloc externs port)))
  244.   (if *comments?*
  245.       (begin (display " /* " port)
  246.          (writex x port)
  247.          (display " */" port)))
  248.   (newline port))
  249.  
  250.  
  251. (define (scsh-emit-d-vector-initializer x reloc port)
  252.   (let ((len (d-vector-length x)))
  253.     (do ((i 0 (+ i 1)))
  254.     ((= i len))
  255.       (scsh-emit-descriptor (d-vector-ref x i) reloc port)
  256.       (write-char #\, port))))
  257.  
  258. (define (scsh-emit-vm-string-initializer x port)
  259.   (let* ((len (vm-string-length x))    ; end is jawilson style hack
  260.      (end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
  261.     (do ((i 0 (+ i 4)))
  262.     ((= i end) 
  263.      (case (- len end)
  264.        ((0)
  265.         (write-hex port 0))
  266.        ((1)
  267.         (write-hex
  268.          port
  269.          (net-to-host-32 (arithmetic-shift 
  270.              (char->ascii (vm-string-ref x i)) 24))))
  271.        ((2)
  272.         (write-hex 
  273.          port
  274.          (net-to-host-32 
  275.           (bitwise-ior
  276.            (arithmetic-shift
  277.         (char->ascii (vm-string-ref x i))       24)
  278.            (arithmetic-shift
  279.         (char->ascii (vm-string-ref x (+ i 1))) 16)))))
  280.        ((3)
  281.         (write-hex
  282.          port
  283.          (net-to-host-32
  284.           (bitwise-ior
  285.            (bitwise-ior
  286.         (arithmetic-shift 
  287.          (char->ascii (vm-string-ref x i))       24)
  288.         (arithmetic-shift 
  289.          (char->ascii (vm-string-ref x (+ i 1))) 16))
  290.            (arithmetic-shift  
  291.         (char->ascii (vm-string-ref x (+ i 2)))  8)))))))
  292.       (write-hex port
  293.          (net-to-host-32 (bitwise-ior
  294.              (bitwise-ior
  295.               (arithmetic-shift 
  296.                (char->ascii (vm-string-ref x i))       24)
  297.               (arithmetic-shift 
  298.                (char->ascii (vm-string-ref x (+ i 1))) 16))
  299.              (bitwise-ior
  300.               (arithmetic-shift 
  301.                (char->ascii (vm-string-ref x (+ i 2)))  8)
  302.               (char->ascii  (vm-string-ref x (+ i 3))))))
  303.          ))))
  304.  
  305. (define (scsh-emit-b-vector-initializer x reloc externs port)
  306.   (cond ((and (code-vector? x)
  307.           (table-ref externs x)) =>
  308.           (lambda (name)
  309.         (format port "(long) *~a," name)))
  310.     (else 
  311.      (let* ((len (b-vector-length x)) ;end is jawilson style hack
  312.         (end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
  313.        (do ((i 0 (+ i 4)))
  314.            ((= i end)
  315.         (case (- len end)
  316.           ((1)
  317.            (write-hex
  318.             port
  319.             (net-to-host-32 (arithmetic-shift (b-vector-ref x i) 24))))
  320.           ((2)
  321.            (write-hex 
  322.             port
  323.             (net-to-host-32
  324.              (bitwise-ior
  325.               (arithmetic-shift (b-vector-ref x i)       24)
  326.               (arithmetic-shift (b-vector-ref x (+ i 1)) 16)))))
  327.           ((3)
  328.            (write-hex
  329.             port
  330.             (net-to-host-32
  331.              (bitwise-ior
  332.               (bitwise-ior
  333.                (arithmetic-shift (b-vector-ref x i)       24)
  334.                (arithmetic-shift (b-vector-ref x (+ i 1)) 16))
  335.               (arithmetic-shift  (b-vector-ref x (+ i 2))  8)))
  336.             ))))
  337.          (write-hex 
  338.           port
  339.           (net-to-host-32 (bitwise-ior
  340.               (bitwise-ior
  341.                (arithmetic-shift (b-vector-ref x i)       24)
  342.                (arithmetic-shift (b-vector-ref x (+ i 1)) 16))
  343.               (bitwise-ior
  344.                (arithmetic-shift (b-vector-ref x (+ i 2))  8)
  345.                (b-vector-ref x (+ i 3))))))))
  346.      )))
  347.  
  348. (define (scsh-emit-descriptor x reloc port)
  349.   (if (stob? x)
  350.       (let ((n (chunk-number x)))
  351.     (display "(long)(&" port)
  352.     (if (immutable? x)
  353.         (display "p" port)
  354.         (display "i" port))
  355.     (display n port)
  356.     (display "[" port)
  357.     (display (quotient (table-ref (vector-ref reloc n) x) 4) port)
  358.     (display "])+7" port))
  359.       (format port 
  360.           (if (negative? x) "-0x~a" "0x~a")
  361.           (number->string (abs x) 16))))
  362.  
  363. (define (scsh-for-each-stored-object chunk-start proc chunk-end)
  364.   (let ((limit (heap-pointer)))
  365.     (let chunk-loop ((addr (newspace-begin))
  366.              (i 0)
  367.              (chunk (+ (newspace-begin) *chunk-size*)))
  368.       (if (addr< addr limit)
  369.       (begin (chunk-start i)
  370.          (let loop ((addr addr))
  371.            (if (and (addr< addr limit)
  372.                 (addr< addr chunk))
  373.                (let* ((d   (fetch addr))
  374.                   (len (addr1+ (header-a-units d))))
  375.              (if (not (header? d))
  376.                  (warn "heap is in an inconsistent state" d))
  377.              (proc i (address->stob-descriptor (addr1+ addr)) len)
  378.              (loop (addr+ addr len)))
  379.                (begin (chunk-end i)
  380.                   (chunk-loop addr
  381.                       (+ i 1)
  382.                       (+ chunk *chunk-size*))))))))))
  383.  
  384. (define (write-hex port x) 
  385.   (format port 
  386.       (if (negative? x) "-0x~a," "0x~a,")
  387.       (number->string (abs x) 16)))
  388.  
  389. ;; takes a string and break it into a list at whitespace
  390. ;; rewrite using scsh stuff?
  391. (define (line->list line)
  392.   (let ((len (string-length line)))
  393.     (let loop ((start 0)
  394.            (end 0)
  395.            (l '()))
  396.       (cond ((>= end len)
  397.          (if (= start end)
  398.          l
  399.          (append l (list (substring line start end)))))
  400.         ((and (= start end)
  401.           (or (char=? (string-ref line start) (ascii->char 32))
  402.               (char=? (string-ref line start) (ascii->char 9))))
  403.          (loop (+ 1 start) 
  404.            (+ 1 end) 
  405.            l))
  406.         ((or (char=? (string-ref line end) (ascii->char 32))
  407.          (char=? (string-ref line end) (ascii->char 9)))
  408.          (loop (+ 1 end) 
  409.            (+ 1 end) 
  410.            (append l (list (substring line start end)))))
  411.         ((< end len)
  412.          (loop start 
  413.            (+ 1 end)
  414.            l))
  415.         (else (error "unexpected case in line->list"))))))
  416.  
  417. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  418. ;;; Debugging
  419. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  420.  
  421. (define (bin n)
  422.   (number->string n 2))
  423.  
  424. (define (oct n)
  425.   (number->string n 8))
  426.  
  427. (define (dec n)
  428.   (number->string n 10))
  429.  
  430. (define (hex n)
  431.   (number->string n 16))
  432.  
  433. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  434. ; For example:
  435. ;   (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
  436. ;
  437. ; The first argument to do-it should be somewhat larger than the size,
  438. ; in bytes, of the image file to be converted (which you can obtain with
  439. ; "ls -l").
  440. ;
  441. ; If the image contains 0-length stored objects, then the .c file will
  442. ; have to be compiled by gcc, since 0-length arrays aren't allowed in
  443. ; ANSI C.  This wouldn't be difficult to work around.
  444.  
  445. (define *comments?* #f)
  446.  
  447. ; 800,000 bytes => 200,000 words => at least 100,000 objects
  448. ;   50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
  449. (define *chunk-size* 10000)
  450.  
  451. (define (do-it bytes infile outfile)
  452.   (let ((start (init bytes infile)))
  453.     (call-with-output-file outfile
  454.       (lambda (port)
  455.     (format port "#define D(x) (long)(&x)+7~%")
  456.     (format port "#define H unsigned long~%")
  457.     (emit-area-declarations "p" immutable? "const " port)
  458.     (emit-area-declarations "i" mutable? "" port)
  459.     (emit-area-initializers "p" immutable? "const " port)
  460.     (emit-area-initializers "i" mutable? "" port)
  461.     (display "const long entry = " port)
  462.     (emit-descriptor start port)
  463.     (write-char #\; port)
  464.     (newline port)))))
  465.  
  466. (define (init bytes infile)
  467.   (create-memory (quotient bytes 2) quiescent) ;Output of ls -l
  468.   (initialize-heap (memory-begin) (memory-size))
  469.   (let ((start (read-image infile 0)))
  470.     (message (nchunks)
  471.          " chunks")
  472.     start))
  473.  
  474. (define (nchunks) (+ (chunk-number (heap-pointer)) 1))
  475.  
  476. ; emit struct declarations for areas
  477.  
  478. (define (emit-area-declarations name in-area? const port)
  479.   (for-each-stored-object
  480.    (lambda (chunk)
  481.      (message name chunk " declaration")
  482.      (display "struct " port) (display name port) (display chunk port)
  483.      (display " {" port) (newline port))
  484.    (lambda (x)
  485.      (if (in-area? x)
  486.      (emit-declaration x port)))
  487.    (lambda (chunk)
  488.      (display "};" port)
  489.      (newline port)
  490.      (display const port)
  491.      (display "extern struct " port) (display name port) (display chunk port)
  492.      (write-char #\space port) (display name port) (display chunk port)
  493.      (write-char #\; port) (newline port)
  494.      chunk)))
  495.  
  496. (define (emit-declaration x port)
  497.   (display "  H x" port)
  498.   (writex x port)
  499.   (cond ((d-vector? x)
  500.      (display "; long d" port)
  501.      (writex x port)
  502.      (write-char #\[ port)
  503.      (write (d-vector-length x) port))
  504.     ((vm-string? x)
  505.      (display "; char d" port)
  506.      (writex x port)
  507.      (write-char #\[ port)
  508.      ;; Ensure alignment (thanks Ian)
  509.      (write (cells->bytes (bytes->cells (b-vector-length x)))
  510.         port))
  511.     (else
  512.      (display "; unsigned char d" port)
  513.      (writex x port)
  514.      (write-char #\[ port)
  515.      ;; Ensure alignment
  516.      (write (cells->bytes (bytes->cells (b-vector-length x)))
  517.         port)))
  518.   (display "];" port)
  519.   (if *comments?*
  520.       (begin (display " /* " port)
  521.          (display (enumerand->name (stob-type x) stob) port)
  522.          (display " */" port)))
  523.   (newline port))
  524.  
  525. ; Emit initializers for areas
  526.  
  527. (define (emit-area-initializers name in-area? const port)
  528.   (for-each-stored-object
  529.    (lambda (chunk)
  530.      (message name chunk " initializer")
  531.  
  532.      (display const port)
  533.      (display "struct " port) (display name port) (write chunk port)
  534.      (write-char #\space port) (display name port) (write chunk port)
  535.      (display " =" port) (newline port)
  536.  
  537.      (write-char #\{ port) (newline port))
  538.    (lambda (x)
  539.      (if (in-area? x)
  540.      (emit-initializer x port)))
  541.    (lambda (chunk)
  542.      (display "};" port) (newline port)))
  543.  
  544.   (let ((n (nchunks)))
  545.     (format port "const long ~a_count = ~s;~%" name n)
  546.     (format port "~a long * const ~a_areas[~s] = {" const name n)
  547.     (do ((i 0 (+ i 1)))
  548.     ((= i n))
  549.       (format port "(~a long *)&~a~s, " const name i))
  550.     (format port "};~%const long ~a_sizes[~s] = {" name n)
  551.     (do ((i 0 (+ i 1)))
  552.     ((= i n))
  553.       (format port "sizeof(~a~s), " name i))
  554.     (format port "};~%")))
  555.  
  556.  
  557. (define (message . stuff)
  558.   (for-each display stuff) (newline))
  559.  
  560. (define (emit-initializer x port)
  561.   (display "  " port)
  562.   (write (stob-header x) port)
  563.   (write-char #\, port)
  564.   (cond ((d-vector? x)
  565.      (emit-d-vector-initializer x port))
  566.     ((vm-string? x)
  567.      (write-char #\" port)
  568.      (let ((len (vm-string-length x)))
  569.        (do ((i 0 (+ i 1)))
  570.            ((= i len) (write-char #\" port))
  571.          (let ((c (vm-string-ref x i)))
  572.            (cond ((or (char=? c #\") (char=? c #\\))
  573.               (write-char #\\ port))
  574.              ((char=? c #\newline)
  575.               (display "\\n\\" port)))
  576.            (write-char c port)))))
  577.     (else
  578.      (write-char #\{ port)
  579.      (let ((len (b-vector-length x)))
  580.        (do ((i 0 (+ i 1)))
  581.            ((= i len) (write-char #\} port))
  582.          (write (b-vector-ref x i) port)
  583.          (write-char #\, port)))))
  584.   (write-char #\, port)
  585.   (if *comments?*
  586.       (begin (display " /* " port)
  587.          (writex x port)
  588.          (display " */" port)))
  589.   (newline port))
  590.  
  591. (define (emit-d-vector-initializer x port)
  592.   (write-char #\{ port)
  593.   (let ((len (d-vector-length x)))
  594.     (do ((i 0 (+ i 1)))
  595.     ((= i len) (write-char #\} port))
  596.       (emit-descriptor (d-vector-ref x i) port)
  597.       (write-char #\, port))))
  598.  
  599. (define (emit-descriptor x port)
  600.   (if (stob? x)
  601.       (begin (if (immutable? x)
  602.          (display "D(p" port)
  603.          (display "D(i" port))
  604.          (display (chunk-number x) port)
  605.          (display ".x" port)
  606.          (writex x port)
  607.          (write-char #\) port))
  608.       (write x port)))
  609.  
  610.  
  611. ; Foo
  612.  
  613. (define (writex x port)
  614.   (write (quotient (- (- x (memory-begin)) 7) 4) port))
  615.  
  616. (define (chunk-number x)
  617.   (quotient (- (- x (memory-begin)) 7) *chunk-size*))
  618.  
  619.  
  620. ; Image traversal utility
  621.  
  622. (define (for-each-stored-object chunk-start proc chunk-end)
  623.   (let ((limit (heap-pointer)))
  624.     (let chunk-loop ((addr (newspace-begin))
  625.              (i 0)
  626.              (chunk (+ (newspace-begin) *chunk-size*)))
  627.       (if (addr< addr limit)
  628.       (begin (chunk-start i)
  629.          (let loop ((addr addr))
  630.            (if (and (addr< addr limit)
  631.                 (addr< addr chunk))
  632.                (let ((d (fetch addr)))
  633.              (if (not (header? d))
  634.                  (warn "heap is in an inconsistent state" d))
  635.              (proc (address->stob-descriptor (addr1+ addr)))
  636.              (loop (addr1+ (addr+ addr (header-a-units d)))))
  637.                (begin (chunk-end i)
  638.                   (chunk-loop addr
  639.                       (+ i 1)
  640.                       (+ chunk *chunk-size*))))))))))
  641.  
  642. (define (mutable? x) (not (immutable? x)))
  643.